home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / Tickle-4.0 (tcl) / tcl / extend / src / tclXprofile.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-11-03  |  25.5 KB  |  818 lines  |  [TEXT/MPS ]
  1. #ifdef MPW
  2. #    pragma segment TCLExtend
  3. #endif
  4. /*
  5.  * tclXprofile.c --
  6.  *
  7.  * Tcl performance profile monitor.
  8.  *-----------------------------------------------------------------------------
  9.  * Copyright 1991-1993 Karl Lehenbauer and Mark Diekhans.
  10.  *
  11.  * Permission to use, copy, modify, and distribute this software and its
  12.  * documentation for any purpose and without fee is hereby granted, provided
  13.  * that the above copyright notice appear in all copies.  Karl Lehenbauer and
  14.  * Mark Diekhans make no representations about the suitability of this
  15.  * software for any purpose.  It is provided "as is" without express or
  16.  * implied warranty.
  17.  *-----------------------------------------------------------------------------
  18.  * $Id: tclXprofile.c,v 2.7 1993/07/30 15:05:15 markd Exp $
  19.  *-----------------------------------------------------------------------------
  20.  */
  21.  
  22. #include "tclExtdInt.h"
  23.  
  24. #ifdef macintosh
  25. #    include <Events.h> /* to get TickCount() */
  26. #endif
  27.  
  28. /*
  29.  * Stack entry used to keep track of an profiling information for active
  30.  * procedure.  Handling uplevels is tricky.  The eval level and procedure call
  31.  * level are kept track of.  These are used to distinguish between an uplevel
  32.  * and exiting a procedure.  During an uplevel, the invisible part of the
  33.  * profile stack is saved on another stack until the uplevel completes.
  34.  */
  35.  
  36. typedef struct profStackEntry_t {
  37.     long                     realTime;      /* Real time at procedure entry. */
  38.     long                     cpuTime;       /* CPU time at procedure entry.  */
  39.     int                      procLevel;     /* Call level of this procedure  */
  40.     int                      evalLevel;     /* Eval level of this prodecure  */
  41.     struct profStackEntry_t *prevEntryPtr;  /* Previous stack entry.         */
  42.     char                     procName [1];  /* Procedure name. MUST BE LAST! */
  43. } profStackEntry_t;
  44.  
  45.  
  46. /*
  47.  * Save stack entry used to hold profile stack entries during an uplevel.
  48.  */
  49.  
  50. typedef struct saveStackEntry_t {
  51.     long                      realTime;      /* Real and CPU time this when  */
  52.     long                      cpuTime;       /* stack section was saved.     */
  53.     profStackEntry_t         *topPtr;        /* Top of saved stack section   */
  54.     profStackEntry_t         *bottomPtr;     /* Bottom of saved stack        */
  55.     struct saveStackEntry_t  *prevEntryPtr;  /* Previous saved stack section */
  56. } saveStackEntry_t;
  57.  
  58. /*
  59.  * Data keeped on a stack snapshot.
  60.  */
  61.  
  62. typedef struct profDataEntry_t {
  63.     long count;
  64.     long realTime;
  65.     long cpuTime;
  66. } profDataEntry_t;
  67.  
  68. /*
  69.  * Client data structure for profile command.  A count of real and CPU time
  70.  * spent outside of the profiling routines is kept to factor out the variable
  71.  * overhead.
  72.  */
  73.  
  74. typedef struct profInfo_t { 
  75.     Tcl_Interp       *interp;            /* Interpreter this is for.         */
  76.     Tcl_Trace         traceHolder;       /* Handle to current trace.         */
  77.     int               allCommands;       /* Prof all commands, not just procs*/
  78.     long              realTime;          /* Real and CPU time counter.       */
  79.     long              cpuTime;
  80.     long              lastRealTime;      /* Real and CPU time of last exit   */
  81.     long              lastCpuTime;       /* from profiling routines.         */
  82.     profStackEntry_t *stackPtr;          /* Pointer to the top of prof stack */
  83.     saveStackEntry_t *saveStackPtr;      /* Frames saved during an uplevel   */
  84.     Tcl_HashTable     profDataTable;     /* Cumulative time table, Keyed by  */
  85.                                          /* call stack list.                 */
  86. } profInfo_t;
  87.  
  88. /*
  89.  * Prototypes of internal functions.
  90.  */
  91.  
  92. static long
  93. GetTimes _ANSI_ARGS_((long  *cpuTimesPtr));
  94.  
  95. static void
  96. ProcEntry _ANSI_ARGS_((profInfo_t *infoPtr,
  97.                        char       *procName,
  98.                        int         procLevel,
  99.                        int         evalLevel));
  100.  
  101. static void
  102. ProcPopEntry _ANSI_ARGS_((profInfo_t *infoPtr));
  103.  
  104. static void
  105. StackSync _ANSI_ARGS_((profInfo_t *infoPtr,
  106.                        int         procLevel,
  107.                        int         evalLevel));
  108.  
  109. static void
  110. DoUplevel _ANSI_ARGS_((profInfo_t *infoPtr,
  111.                        int         procLevel));
  112.  
  113. static void
  114. ProfTraceRoutine _ANSI_ARGS_((ClientData    clientData,
  115.                               Tcl_Interp   *interp,
  116.                               int           evalLevel,
  117.                               char         *command,
  118.                               int           (*cmdProc)(),
  119.                               ClientData    cmdClientData,
  120.                               int           argc,
  121.                               char        **argv));
  122.  
  123. static void
  124. CleanDataTable _ANSI_ARGS_((profInfo_t *infoPtr));
  125.  
  126. static void
  127. DeleteProfTrace _ANSI_ARGS_((profInfo_t *infoPtr));
  128.  
  129. static int
  130. DumpTableData  _ANSI_ARGS_((Tcl_Interp *interp,
  131.                             profInfo_t *infoPtr,
  132.                             char       *varName));
  133.  
  134. static int
  135. Tcl_ProfileCmd _ANSI_ARGS_((ClientData    clientData,
  136.                             Tcl_Interp   *interp,
  137.                             int           argc,
  138.                             char        **argv));
  139.  
  140. static void
  141. CleanUpProfMon _ANSI_ARGS_((ClientData  clientData,
  142.                             Tcl_Interp *interp));
  143.  
  144. #ifdef TIMES_RETS_REAL_TIME
  145.  
  146. /*
  147.  *-----------------------------------------------------------------------------
  148.  * GetTimes --
  149.  *
  150.  *   Get the current real and CPU time for the process.  This version of this
  151.  * function is used on systems where the times systems call returns the
  152.  * elasped real time.
  153.  *
  154.  * Parameters:
  155.  *   o cpuTimePtr (O) - The CPU time in milliseconds is returned here.
  156.  * Returns:
  157.  *   The current real time of the process, in milliseconds.
  158.  *-----------------------------------------------------------------------------
  159.  */
  160. static long
  161. GetTimes (cpuTimePtr)
  162.     long  *cpuTimePtr;
  163.     {
  164.     long       realTime;
  165. #ifndef macintosh
  166.     struct tms cpuTimes;
  167. #endif
  168.  
  169. #ifdef macintosh
  170.     realTime = TickCount() * MS_PER_TICK;
  171. #else
  172.     realTime = times(&cpuTimes) * MS_PER_TICK;
  173. #endif
  174.  
  175. #ifdef macintosh
  176.     *cpuTimePtr = TickCount() * MS_PER_TICK;
  177. #else
  178.     *cpuTimePtr = (cpuTimes.tms_utime + cpuTimes.tms_stime) * MS_PER_TICK;
  179. #endif
  180.  
  181.     return realTime;
  182.     }
  183.     
  184. #else
  185.  
  186. /*
  187.  *-----------------------------------------------------------------------------
  188.  * GetTimes --
  189.  *
  190.  *   Get the current real and CPU time for the process.  This version of this
  191.  * function is used on systems where the times systems call does not return the
  192.  * elasped real time.  It uses gettimeofday to figure out the real time.
  193.  *
  194.  * Parameters:
  195.  *   o cpuTimePtr (O) - The CPU time in milliseconds is returned here.
  196.  * Returns:
  197.  *   The current real time of the process, in milliseconds, relative to the
  198.  * first time this function was called.
  199.  *-----------------------------------------------------------------------------
  200.  */
  201. static long
  202. GetTimes (cpuTimePtr)
  203.     long  *cpuTimePtr;
  204.     {
  205.     static struct timeval startTime = {0, 0};
  206.     struct timeval        currentTime;
  207.     struct tms            cpuTimes;
  208.     long                  realTime;
  209.  
  210.     /*
  211.      * If this is the first call, get base time.
  212.      */
  213.     if ((startTime.tv_sec == 0) && (startTime.tv_usec == 0))
  214.         gettimeofday (&startTime, NULL);
  215.     
  216.     gettimeofday (¤tTime, NULL);
  217.     currentTime.tv_sec  = currentTime.tv_sec  - startTime.tv_sec;
  218.     currentTime.tv_usec = currentTime.tv_usec - startTime.tv_usec;
  219.     realTime = (currentTime.tv_sec  * 1000) +
  220.                (currentTime.tv_usec / 1000);
  221.     times (&cpuTimes);
  222.     *cpuTimePtr = (cpuTimes.tms_utime + cpuTimes.tms_stime) * MS_PER_TICK;
  223.     return realTime;
  224.     }
  225. #endif /* TIMES_RETS_REAL_TIME */
  226.  
  227. /*
  228.  *-----------------------------------------------------------------------------
  229.  * ProcEntry --
  230.  *
  231.  *   Push a procedure entry onto the stack.
  232.  *
  233.  * Parameters:
  234.  *   o infoPtr (I/O) - The global profiling info.
  235.  *   o procName (I)  The procedure name.
  236.  *   o procLevel (I) - The procedure call level that the procedure will
  237.  *     execute at.
  238.  *   o evalLevel (I) - The eval level that the procedure will start
  239.  *     executing at.
  240.  *-----------------------------------------------------------------------------
  241.  */
  242. static void
  243. ProcEntry (infoPtr, procName, procLevel, evalLevel)
  244.     profInfo_t *infoPtr;
  245.     char       *procName;
  246.     int         procLevel;
  247.     int         evalLevel;
  248.     {
  249.     profStackEntry_t *entryPtr;
  250.  
  251.     /*
  252.      * Calculate the size of an entry.  One byte for name is in the entry.
  253.      */
  254.     entryPtr = (profStackEntry_t *) ckalloc (sizeof (profStackEntry_t) +
  255.                                              strlen (procName));
  256.     
  257.     /*
  258.      * Fill it in and push onto the stack.  Note that the procedures frame has
  259.      * not yet been layed down or the procedure body eval execute, so the value
  260.      * they will be in the procedure is recorded.
  261.      */
  262.     entryPtr->realTime     = infoPtr->realTime;
  263.     entryPtr->cpuTime      = infoPtr->cpuTime;
  264.     entryPtr->procLevel    = procLevel;
  265.     entryPtr->evalLevel    = evalLevel;
  266.     strcpy (entryPtr->procName, procName);
  267.  
  268.     entryPtr->prevEntryPtr  = infoPtr->stackPtr;
  269.     infoPtr->stackPtr       = entryPtr;
  270.     }
  271.  
  272. /*
  273.  *-----------------------------------------------------------------------------
  274.  * ProcPopEntry --
  275.  *
  276.  *   Pop the procedure entry from the top of the stack and record its
  277.  * times in the data table.
  278.  *
  279.  * Parameters:
  280.  *   o infoPtr (I/O) - The global profiling info.
  281.  *-----------------------------------------------------------------------------
  282.  */
  283. static void
  284. ProcPopEntry (infoPtr)
  285.     profInfo_t *infoPtr;
  286.     {
  287.     profStackEntry_t *entryPtr = infoPtr->stackPtr;
  288.     profStackEntry_t *scanPtr;
  289.     int               idx, newEntry;
  290.     char             *stackListPtr;
  291.     Tcl_HashEntry    *hashEntryPtr;
  292.     profDataEntry_t  *dataEntryPtr;
  293.     char             *stackArgv [MAX_NESTING_DEPTH];
  294.  
  295.     /*
  296.      * Build up a stack list.  Entry [0] is the top of the stack.
  297.      */
  298.     idx= 0;
  299.     scanPtr = entryPtr;
  300.     while (scanPtr != NULL)
  301.         {
  302.         stackArgv [idx] = scanPtr->procName;
  303.         idx++;
  304.         scanPtr = scanPtr->prevEntryPtr;
  305.         }
  306.     stackListPtr = Tcl_Merge (idx, stackArgv);
  307.  
  308.     /*
  309.      * Check the hash table for this entry, either finding an existing or
  310.      * creating a new hash entry.
  311.      */
  312.  
  313.     hashEntryPtr = Tcl_CreateHashEntry (&infoPtr->profDataTable,
  314.                                         stackListPtr,
  315.                                         &newEntry);
  316.     ckfree (stackListPtr);
  317.  
  318.     /*
  319.      * Fill in or increment the entry.
  320.      */
  321.     if (newEntry)
  322.         {
  323.         dataEntryPtr = (profDataEntry_t *) ckalloc (sizeof (profDataEntry_t));
  324.         Tcl_SetHashValue (hashEntryPtr, dataEntryPtr);
  325.         dataEntryPtr->count    = 0;
  326.         dataEntryPtr->realTime = 0;
  327.         dataEntryPtr->cpuTime  = 0;;
  328.         }
  329.     else
  330.         dataEntryPtr = (profDataEntry_t *) Tcl_GetHashValue (hashEntryPtr);
  331.  
  332.     dataEntryPtr->count++;
  333.     dataEntryPtr->realTime += (infoPtr->realTime - entryPtr->realTime);
  334.     dataEntryPtr->cpuTime  += (infoPtr->cpuTime  - entryPtr->cpuTime);
  335.  
  336.  
  337.     infoPtr->stackPtr = entryPtr->prevEntryPtr;
  338.     ckfree ((char *) entryPtr);
  339.     }
  340.  
  341. /*
  342.  *-----------------------------------------------------------------------------
  343.  * StackSync --
  344.  *
  345.  *   Synchronize the profile stack with the interpreter procedure stack.
  346.  * This is done once return from uplevels, exits and error unwinds are
  347.  * detected (the command after).  Saved profile stack entries may be
  348.  * restored and procedure entries popped from the stack.  When entries
  349.  * are popped, their statistics is saved in stack.
  350.  *
  351.  * Parameters:
  352.  *   o infoPtr (I/O) - The global profiling info.
  353.  *   o procLevel (I) - Procedure call level to return to (zero to clear stack).
  354.  *   o evalLevel (I) - Eval call level to return to (zero to clear stack).
  355.  *-----------------------------------------------------------------------------
  356.  */
  357. static void
  358. StackSync (infoPtr, procLevel, evalLevel)
  359.     profInfo_t *infoPtr;
  360.     int         procLevel;
  361.     int         evalLevel;
  362.     {
  363.     long              cpuDelta;
  364.     long              realDelta;
  365.     profStackEntry_t *endPtr;
  366.     profStackEntry_t *scanPtr;
  367.     saveStackEntry_t *saveEntryPtr;
  368.     
  369.     while (TRUE)
  370.         {
  371.         /*
  372.          * Move top of saved stack to standard stack if stack is empty or
  373.          * saved eval level is greater than the top of the standard stack.
  374.          */
  375.         saveEntryPtr = infoPtr->saveStackPtr;
  376.  
  377.         if ((saveEntryPtr != NULL) && 
  378.             ((infoPtr->stackPtr == NULL) || 
  379.              (saveEntryPtr->topPtr->evalLevel >
  380.               infoPtr->stackPtr->evalLevel))) {
  381.  
  382.         /*
  383.          * To prevent the saved entries from getting `charged' with
  384.          * with the time they've been idling here in limbo, advance
  385.          * their 'start' times by the amount of time they'be been
  386.          * idling.  This prevents time spent executing uplevel-ed
  387.          * code from being counted twice.
  388.          */
  389.         cpuDelta  = infoPtr->cpuTime  - saveEntryPtr->cpuTime;
  390.         realDelta = infoPtr->realTime - saveEntryPtr->realTime;
  391.         endPtr    = saveEntryPtr->bottomPtr->prevEntryPtr;
  392.         scanPtr   = saveEntryPtr->topPtr;
  393.         while (scanPtr != endPtr) {
  394.         scanPtr->cpuTime  += cpuDelta;
  395.         scanPtr->realTime += realDelta;
  396.  
  397.         scanPtr = scanPtr->prevEntryPtr;
  398.         }
  399.  
  400.             infoPtr->stackPtr = saveEntryPtr->topPtr;
  401.             infoPtr->saveStackPtr = saveEntryPtr->prevEntryPtr;
  402.             ckfree ((char *) saveEntryPtr);
  403.  
  404.         } else {
  405.  
  406.             if ((infoPtr->stackPtr == NULL) ||
  407.                 ((procLevel >= infoPtr->stackPtr->procLevel) &&
  408.                  (evalLevel >= infoPtr->stackPtr->evalLevel)))
  409.                 break;  /* Done */
  410.             ProcPopEntry (infoPtr);
  411.  
  412.         }
  413.     }
  414. }
  415.  
  416. /*
  417.  *-----------------------------------------------------------------------------
  418.  * DoUplevel --
  419.  *
  420.  *   Do processing required when an uplevel is detected.  Builds and
  421.  * pushes a save stack containing all of the save entrys that have been
  422.  * hiden by the uplevel.  
  423.  *
  424.  * Parameters:
  425.  *   o infoPtr (I/O) - The global profiling info.
  426.  *   o procLevel (I) - The upleveled procedure call level.
  427.  *-----------------------------------------------------------------------------
  428.  */
  429. static void
  430. DoUplevel (infoPtr, procLevel)
  431.     profInfo_t *infoPtr;
  432.     int         procLevel;
  433.     {
  434.     profStackEntry_t *scanPtr, *bottomPtr;
  435.     saveStackEntry_t *saveEntryPtr;
  436.  
  437.     /*
  438.      * Find the stack area to save.
  439.      */
  440.     bottomPtr = NULL;
  441.     scanPtr = infoPtr->stackPtr;
  442.     while ((scanPtr != NULL) && (scanPtr->procLevel > procLevel))
  443.         {
  444.         bottomPtr = scanPtr;
  445.         scanPtr = scanPtr->prevEntryPtr;
  446.         }
  447.     if (bottomPtr == NULL)
  448.         panic ("uplevel stack confusion");
  449.  
  450.     /*
  451.      * Save the stack entries in the save stack.
  452.      */
  453.     saveEntryPtr = (saveStackEntry_t *) ckalloc (sizeof (saveStackEntry_t));
  454.     saveEntryPtr->cpuTime      = infoPtr->cpuTime;
  455.     saveEntryPtr->realTime     = infoPtr->realTime;
  456.     saveEntryPtr->topPtr       = infoPtr->stackPtr;
  457.     saveEntryPtr->bottomPtr    = bottomPtr;
  458.     saveEntryPtr->prevEntryPtr = infoPtr->saveStackPtr;;
  459.  
  460.     infoPtr->saveStackPtr = saveEntryPtr;
  461.  
  462.     /*
  463.      * Hide the stack entries.
  464.      */
  465.     infoPtr->stackPtr = bottomPtr->prevEntryPtr;
  466.     }
  467.  
  468. /*
  469.  *-----------------------------------------------------------------------------
  470.  * ProfTraceRoutine --
  471.  *
  472.  *  Routine called by Tcl_Eval to do profiling.
  473.  *-----------------------------------------------------------------------------
  474.  */
  475. static void
  476. ProfTraceRoutine (clientData, interp, evalLevel, command, cmdProc,
  477.                   cmdClientData, argc, argv)
  478.     ClientData    clientData;
  479.     Tcl_Interp   *interp;
  480.     int           evalLevel;
  481.     char         *command;
  482.     int           (*cmdProc)();
  483.     ClientData    cmdClientData;
  484.     int           argc;
  485.     char        **argv;
  486.     {
  487.     Interp      *iPtr      = (Interp *) interp;
  488.     profInfo_t  *infoPtr   = (profInfo_t *) clientData;
  489.     int          procLevel = (iPtr->varFramePtr == NULL) ? 0 : 
  490.                              iPtr->varFramePtr->level;
  491.     long         cpuTime;
  492.  
  493.     /*
  494.      * Calculate the time spent since the last trace.
  495.      */
  496.     infoPtr->realTime += GetTimes(&cpuTime) - infoPtr->lastRealTime;
  497.     infoPtr->cpuTime  += cpuTime - infoPtr->lastCpuTime;
  498.     
  499.     /*
  500.      * If the procedure level has changed, then something is up.  Its not a
  501.      * procedure call, as we head them off before they happen.  Its one of
  502.      * four events.
  503.      *
  504.      *   o A uplevel command was executed.
  505.      *   o Returned from an uplevel.
  506.      *   o A procedure exit has occured.
  507.      *   o An error unwind has occured.
  508.      *     
  509.      * Eval level must be tested as well as proc level to cover upleveled
  510.      * proc calls that don't execute any commands.
  511.      */
  512.      
  513.     if ((infoPtr->stackPtr != NULL) && 
  514.         ((procLevel != infoPtr->stackPtr->procLevel) ||
  515.          (evalLevel <  infoPtr->stackPtr->evalLevel))) {
  516.  
  517.         if ((procLevel < infoPtr->stackPtr->procLevel) &&
  518.             (evalLevel > infoPtr->stackPtr->evalLevel))
  519.             DoUplevel (infoPtr, procLevel);
  520.         else
  521.             StackSync (infoPtr, procLevel, evalLevel);
  522.     }
  523.  
  524.     /*
  525.      * If this is level zero and the stack is empty, add an entry for the
  526.      * global level.  This takes care of the first command at the global level
  527.      * after profiling has been enabled or the case where profiling was
  528.      * enabled in a proc and we have returned to the global level.
  529.      */
  530.      if ((infoPtr->stackPtr == NULL) && (procLevel == 0))
  531.          ProcEntry (infoPtr, "<global>", 0, evalLevel);
  532.  
  533.     /*
  534.      * If this command is a procedure or if all commands are being traced,
  535.      * handle the entry.
  536.      */
  537.  
  538.     if (infoPtr->allCommands || (TclFindProc (iPtr, argv [0]) != NULL))
  539.         ProcEntry (infoPtr, argv [0], procLevel + 1, evalLevel + 1);
  540.  
  541.     /*
  542.      * Save the exit time of the profiling trace handler.
  543.      */
  544.     infoPtr->lastRealTime = GetTimes(&infoPtr->lastCpuTime);
  545.     }
  546.  
  547. /*
  548.  *-----------------------------------------------------------------------------
  549.  * CleanDataTable --
  550.  *
  551.  *  Clean up the hash data table, releasing all resources and setting it
  552.  *  to the empty state.
  553.  *
  554.  * Parameters:
  555.  *   o infoPtr (I/O) - The global profiling info.
  556.  *-----------------------------------------------------------------------------
  557.  */
  558. static void
  559. CleanDataTable (infoPtr)
  560.     profInfo_t *infoPtr;
  561.     {
  562.     Tcl_HashEntry    *hashEntryPtr;
  563.     Tcl_HashSearch   searchCookie;
  564.  
  565.     hashEntryPtr = Tcl_FirstHashEntry (&infoPtr->profDataTable,
  566.                                        &searchCookie);
  567.     while (hashEntryPtr != NULL)
  568.         {
  569.         ckfree ((char *) Tcl_GetHashValue (hashEntryPtr));
  570.         Tcl_DeleteHashEntry (hashEntryPtr);
  571.         hashEntryPtr = Tcl_NextHashEntry (&searchCookie);
  572.         }
  573.     }
  574.  
  575. /*
  576.  *-----------------------------------------------------------------------------
  577.  * DeleteProfTrace --
  578.  *
  579.  *   Delete the profile trace and clean up the stack, logging all procs
  580.  * as if they had exited.  Data table must still be available.
  581.  *
  582.  * Parameters:
  583.  *   o infoPtr (I/O) - The global profiling info.
  584.  *-----------------------------------------------------------------------------
  585.  */
  586. static void
  587. DeleteProfTrace (infoPtr)
  588.     profInfo_t *infoPtr;
  589.     {
  590.     Tcl_DeleteTrace (infoPtr->interp, infoPtr->traceHolder);
  591.     infoPtr->traceHolder = NULL;
  592.  
  593.     StackSync (infoPtr, 0, 0);
  594.     }
  595.  
  596. /*
  597.  *-----------------------------------------------------------------------------
  598.  * DumpTableData --
  599.  *
  600.  *   Dump the table data to an array variable.  Entries will be deleted
  601.  * as they are dumped to limit memory utilization.
  602.  *
  603.  * Parameters:
  604.  *   o interp (I) - Pointer to the interprer.
  605.  *   o infoPtr (I/O) - The global profiling info.
  606.  *   o varName (I) - The name of the variable to save the data in.
  607.  * Returns:
  608.  *   Standard Tcl command results
  609.  *-----------------------------------------------------------------------------
  610.  */
  611. static int
  612. DumpTableData (interp, infoPtr, varName)
  613.     Tcl_Interp *interp;
  614.     profInfo_t *infoPtr;
  615.     char       *varName;
  616.     {
  617.     Tcl_HashEntry    *hashEntryPtr;
  618.     Tcl_HashSearch    searchCookie;
  619.     profDataEntry_t  *dataEntryPtr;
  620.     char             *dataArgv [3], *dataListPtr;
  621.     char              countBuf [32], realTimeBuf [32], cpuTimeBuf [32];
  622.  
  623.     dataArgv [0] = countBuf;
  624.     dataArgv [1] = realTimeBuf;
  625.     dataArgv [2] = cpuTimeBuf;
  626.  
  627.     Tcl_UnsetVar (interp, varName, 0);
  628.     hashEntryPtr = Tcl_FirstHashEntry (&infoPtr->profDataTable,
  629.                                        &searchCookie);
  630.     while (hashEntryPtr != NULL)
  631.         {
  632.         dataEntryPtr = 
  633.             (profDataEntry_t *) Tcl_GetHashValue (hashEntryPtr);
  634.  
  635.         sprintf (countBuf,    "%ld", dataEntryPtr->count);
  636.         sprintf (realTimeBuf, "%ld", dataEntryPtr->realTime);
  637.         sprintf (cpuTimeBuf,  "%ld", dataEntryPtr->cpuTime);
  638.  
  639.         dataListPtr = Tcl_Merge (3, dataArgv);
  640.  
  641.         if (Tcl_SetVar2 (interp, varName,
  642.                          Tcl_GetHashKey (&infoPtr->profDataTable,
  643.                                          hashEntryPtr),
  644.                          dataListPtr, TCL_LEAVE_ERR_MSG) == NULL) {
  645.             ckfree (dataListPtr);
  646.             return TCL_ERROR;
  647.             }
  648.         ckfree (dataListPtr);
  649.         ckfree ((char *) dataEntryPtr);
  650.         Tcl_DeleteHashEntry (hashEntryPtr);
  651.  
  652.         hashEntryPtr = Tcl_NextHashEntry (&searchCookie);
  653.         }
  654.  
  655.     return TCL_OK;
  656.     }
  657.  
  658. /*
  659.  *-----------------------------------------------------------------------------
  660.  * Tcl_ProfileCmd --
  661.  *
  662.  *   Implements the TCL profile command:
  663.  *     profile ?-commands? on
  664.  *     profile off arrayvar
  665.  *-----------------------------------------------------------------------------
  666.  */
  667. static int
  668. Tcl_ProfileCmd (clientData, interp, argc, argv)
  669.     ClientData    clientData;
  670.     Tcl_Interp   *interp;
  671.     int           argc;
  672.     char        **argv;
  673.     {
  674.     Interp      *iPtr = (Interp *) interp;
  675.     profInfo_t  *infoPtr = (profInfo_t *) clientData;
  676.     int          idx;
  677.     int          cmdArgc,   optionsArgc = 0;
  678.     char       **cmdArgv, **optionsArgv = &(argv [1]);
  679.  
  680.     /*
  681.      * Scan for options (currently only one is supported).  Set cmdArgv to
  682.      * contain the rest of the command following the options.
  683.      */
  684.     for (idx = 1; (idx < argc) && (argv [idx][0] == '-'); idx++)
  685.         optionsArgc++;
  686.     cmdArgc = argc - idx;
  687.     cmdArgv = &(argv [idx]);
  688.  
  689.     if (cmdArgc < 1)
  690.         goto wrongArgs;
  691.  
  692.     /*
  693.      * Handle the on command.
  694.      */
  695.     if (STREQU (cmdArgv [0], "on"))
  696.         {
  697.         int  allCommands = FALSE;
  698.  
  699.         if ((cmdArgc != 1) || (optionsArgc > 1))
  700.             goto wrongArgs;
  701.  
  702.         if (optionsArgc == 1)
  703.             {
  704.             if (!STREQU (optionsArgv [0], "-commands"))
  705.                 {
  706.                 Tcl_AppendResult (interp, "expected option of \"-commands\", ",
  707.                                   "got \"", optionsArgv [0], "\"",
  708.                                   (char *) NULL);
  709.                 return TCL_ERROR;
  710.                 }
  711.             allCommands = TRUE;
  712.             }
  713.  
  714.         if (infoPtr->traceHolder != NULL)
  715.             {
  716.             Tcl_AppendResult (interp, "profiling is already enabled",
  717.                               (char *) NULL);
  718.             return TCL_ERROR;
  719.             }
  720.             
  721.         CleanDataTable (infoPtr);
  722.         infoPtr->traceHolder =
  723.             Tcl_CreateTrace (interp, MAXINT,
  724.                              (Tcl_CmdTraceProc *) ProfTraceRoutine,
  725.                              (ClientData) infoPtr);
  726.         infoPtr->realTime = 0;
  727.         infoPtr->cpuTime  = 0;
  728.         infoPtr->lastRealTime = GetTimes(&infoPtr->lastCpuTime);
  729.         infoPtr->allCommands = allCommands;
  730.         return TCL_OK;
  731.         }
  732.  
  733.     /*
  734.      * Handle the off command.  Dump the hash table to a variable.
  735.      */
  736.     if (STREQU (cmdArgv [0], "off"))
  737.         {
  738.  
  739.         if ((cmdArgc != 2) || (optionsArgc > 0))
  740.             goto wrongArgs;
  741.  
  742.         if (infoPtr->traceHolder == NULL)
  743.             {
  744.             Tcl_AppendResult (interp, "profiling is not currently enabled",
  745.                               (char *) NULL);
  746.             return TCL_ERROR;
  747.             }
  748.             
  749.         DeleteProfTrace (infoPtr);
  750.  
  751.         if (DumpTableData (interp, infoPtr, argv [2]) != TCL_OK)
  752.             return TCL_ERROR;
  753.         return TCL_OK;
  754.         }
  755.  
  756.     /*
  757.      * Not a valid subcommand.
  758.      */
  759.     Tcl_AppendResult (interp, "expected one of \"on\" or \"off\", got \"",
  760.                       argv [1], "\"", (char *) NULL);
  761.     return TCL_ERROR;
  762.  
  763.   wrongArgs:
  764.     Tcl_AppendResult (interp, tclXWrongArgs, argv [0],
  765.                       " ?-commands? on|off arrayVar", (char *) NULL);
  766.     return TCL_ERROR;
  767. }
  768.  
  769. /*
  770.  *-----------------------------------------------------------------------------
  771.  * ProfMonCleanUp --
  772.  *
  773.  *   Release the client data area when the interpreter is deleted.
  774.  *-----------------------------------------------------------------------------
  775.  */
  776. static void
  777. ProfMonCleanUp (clientData, interp)
  778.     ClientData  clientData;
  779.     Tcl_Interp *interp;
  780.     {
  781.     profInfo_t *infoPtr = (profInfo_t *) clientData;
  782.  
  783.     if (infoPtr->traceHolder != NULL)
  784.         DeleteProfTrace (infoPtr);
  785.     CleanDataTable (infoPtr);
  786.     Tcl_DeleteHashTable (&infoPtr->profDataTable);
  787.     ckfree ((char *) infoPtr);
  788.     }
  789.  
  790. /*
  791.  *-----------------------------------------------------------------------------
  792.  * Tcl_InitProfile --
  793.  *
  794.  *   Initialize the Tcl profiling command.
  795.  *-----------------------------------------------------------------------------
  796.  */
  797. void
  798. Tcl_InitProfile (interp)
  799.     Tcl_Interp *interp;
  800.     {
  801.     profInfo_t *infoPtr;
  802.  
  803.     infoPtr = (profInfo_t *) ckalloc (sizeof (profInfo_t));
  804.  
  805.     infoPtr->interp       = interp;
  806.     infoPtr->traceHolder  = NULL;
  807.     infoPtr->stackPtr     = NULL;
  808.     infoPtr->saveStackPtr = NULL;
  809.     
  810.     Tcl_InitHashTable (&infoPtr->profDataTable, TCL_STRING_KEYS);
  811.  
  812.     Tcl_CallWhenDeleted (interp, ProfMonCleanUp, (ClientData) infoPtr);
  813.  
  814.     Tcl_CreateCommand (interp, "profile", Tcl_ProfileCmd, 
  815.                        (ClientData) infoPtr, (void (*)()) NULL);
  816.     }
  817.  
  818.